home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / packages / webster.el < prev    next >
Encoding:
Text File  |  1995-03-05  |  16.8 KB  |  510 lines
  1. ;; Copyright (C) 1989 Free Software Foundation
  2.  
  3. ;; This file is part of GNU Emacs.
  4.  
  5. ;; GNU Emacs is distributed in the hope that it will be useful,
  6. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  7. ;; accepts responsibility to anyone for the consequences of using it
  8. ;; or for whether it serves any particular purpose or works at all,
  9. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  10. ;; License for full details.
  11.  
  12. ;; Everyone is granted permission to copy, modify and redistribute
  13. ;; GNU Emacs, but only under the conditions described in the
  14. ;; GNU Emacs General Public License.   A copy of this license is
  15. ;; supposed to have been given to you along with GNU Emacs so you
  16. ;; can know your rights and responsibilities.  It should be in a
  17. ;; file named COPYING.  Among other things, the copyright notice
  18. ;; and this notice must be preserved on all copies.
  19. ;;
  20. ;; Author Jason R. Glasgow (glasgow@cs.yale.edu)
  21. ;; Modified from telnet.el by William F. Schelter
  22. ;; But almost entirely different.
  23. ;;
  24. ;; Modified by Dirk Grunwald to maintain an open connection.
  25. ;;
  26. ;; 3/18/89 Ashwin Ram <Ram-Ashwin@yale.edu>
  27. ;; Added webster-mode.
  28. ;; Fixed documentation.
  29. ;;
  30. ;; 3/20/89 Dirk Grunwald <grunwald@flute.cs.uiuc.edu>
  31. ;; Merged Rams changes with new additions: smarter window placement,
  32. ;; correctly handles un-exposed webster windows, minor cleanups.
  33. ;; Also, ``webster-word'', akin to ``spell-word''.
  34. ;;
  35. ;; To use this, you might want to add this line to your .emacs file:
  36. ;;
  37. ;;  (autoload 'webster "webster" "look up a word in Webster's 7th edition" t)
  38. ;;
  39. ;; Then just hit M-x webster to look up a word.
  40. ;;
  41. ;; 3/21/89 Dave Sill <dsill@relay.nswc.navy.mil>
  42. ;; Removed webster-word and webster-define, adding default of current word to 
  43. ;; webster, webster-spell, and webster-endings instead.
  44. ;;
  45. ;; 1/21/91 Jamie Zawinski <jwz@lucid.com>
  46. ;; Added webster-reformat to produce better looking output.  Made it notice
  47. ;; references to other words in the definitions (all upper-case) and do
  48. ;; completion on them in the string read by meta-x webster.
  49. ;;
  50. ;; 9/14/91 Jamie Zawinski <jwz@lucid.com>
  51. ;; Improved the above.
  52. ;;
  53. ;; 4/15/92 Jamie Zawinski <jwz@lucid.com>
  54. ;; Improved formatting some more, and added Lucid GNU Emacs font and mouse
  55. ;; support (mostly cannibalized from webster-ucb.el.)
  56.  
  57. (defvar webster-host "agate.berkeley.edu" ;"129.79.254.192"
  58.   "The host to use as a webster server.")
  59.  
  60. (defvar webster-port "2627"
  61.   "The port to connect to. Either 103 or 2627")
  62.  
  63. (defvar webster-process nil
  64.   "The current webster process")
  65.  
  66. (defvar webster-process-name "webster"
  67.   "The current webster process")
  68.  
  69. (defvar webster-buffer nil
  70.   "The current webster process")
  71.  
  72. (defvar webster-running nil
  73.   "Used to determine when connection is established")
  74.  
  75. ;;;
  76. ;;; Initial filter for ignoring information until successfully connected
  77. ;;;
  78. (defun webster-initial-filter (proc string)
  79.   (let ((this-buffer (current-buffer)))
  80.     (set-buffer webster-buffer)
  81.     (goto-char (point-max))
  82.     (cond ((not (eq (process-status webster-process) 'run))
  83.        (setq webster-running t)
  84.        (message "Webster died"))
  85.       ((string-match "No such host" string)
  86.        (setq webster-running t)
  87.        (kill-buffer (process-buffer proc))
  88.        (error "No such host."))
  89.       ((string-match "]" string)
  90.        (setq webster-running t)
  91.        (set-process-filter proc 'webster-filter)))
  92.     (set-buffer this-buffer)))
  93.  
  94. (defvar webster-reformat t
  95.   "*Set this to t if you want the webster output to be prettied up, and
  96. for the \\[webster] prompt to do completion across the set of words known
  97. to be in the dictionary (words you've looked up, or which appeared in 
  98. definitions as crossreferences.)")
  99.  
  100. (defun webster-filter (proc string)
  101.   (let ((this-buffer (current-buffer))
  102.     (endp nil))
  103.     (set-buffer webster-buffer)
  104.     (cond ((not (eq (process-status webster-process) 'run))
  105.        (message "Webster died"))
  106.       ((string-match "Connection closed" string)
  107.        (message "Closing webster connection...")
  108.        (kill-process proc)
  109.        (replace-regexp "Process webster killed" "" nil)
  110.        (goto-char 1)
  111.        (message "Closing webster connection...Done."))
  112.       ((string-match "SPELLING 0" string)
  113.        (insert "...Word not found in webster\n"))
  114.       ((string-match "SPELLING 1" string)
  115.        (insert "...Spelled correctly\n"))
  116.       ((let ((end-def-message (or (string-match "\200" string)
  117.                       (string-match "\0" string))))
  118.          (if end-def-message
  119.          (progn
  120.            (webster-filter
  121.             proc
  122.             (concat (substring string 0 (- end-def-message 1)) "\n\n"))
  123.            (setq endp t)
  124.            (goto-char (point-max))
  125.            t))))
  126.       (t
  127.        (goto-char (point-max))
  128.        (let ((now (point)))
  129.          (insert string)
  130.          (delete-char-in-region now (point) "\^M" " "))
  131.        (if (process-mark proc)
  132.            (set-marker (process-mark proc) (point)))))
  133.     (if endp
  134.     ;; if the webster window is visible, move the last line to the
  135.     ;; bottom of that window
  136.     (let ((webster-window (get-buffer-window webster-buffer))
  137.           (window (selected-window)))
  138.       (if webster-reformat (webster-reformat (process-mark proc)))
  139.       (if webster-window
  140.           (progn
  141.         (select-window webster-window)
  142.         (goto-char (point-max))
  143.         (recenter (1- (window-height webster-window)))
  144.         (select-window window)))))))
  145.  
  146. (defconst webster-completion-table (make-vector 511 0))
  147.  
  148. (defun webster-intern (string)
  149.   (while (string-match "\\." string)
  150.     (setq string (concat (substring string 0 (match-beginning 0))
  151.              (substring string (match-end 0)))))
  152.   (intern (downcase string) webster-completion-table))
  153.  
  154. (defvar webster-fontify (string-match "XEmacs" emacs-version)
  155.   "*Set to t to use the XEmacs/Lucid Emacs font-change mechanism.")
  156.  
  157. (cond ((fboundp 'make-face)
  158.        (or (find-face 'webster)
  159.        (face-differs-from-default-p (make-face 'webster))
  160.        (copy-face 'default 'webster))
  161.        (or (find-face 'webster-bold)
  162.        (face-differs-from-default-p (make-face 'webster-bold))
  163.        (copy-face 'bold 'webster-bold))
  164.        (or (find-face 'webster-italic)
  165.        (face-differs-from-default-p (make-face 'webster-italic))
  166.        (copy-face 'italic 'webster-italic))
  167.        (or (find-face 'webster-bold-italic)
  168.        (face-differs-from-default-p (make-face 'webster-bold-italic))
  169.        (copy-face 'bold-italic 'webster-bold-italic))
  170.        (or (find-face 'webster-small)
  171.        (face-differs-from-default-p (make-face 'webster-small))
  172.        (copy-face 'webster-bold 'webster-small))
  173.        ))
  174.  
  175. (defun webster-fontify (start end face &optional highlight)
  176.   (let ((e (make-extent start end (current-buffer))))
  177.     (set-extent-face e face)
  178.     (if highlight (set-extent-property e 'highlight t))))
  179.  
  180.  
  181. (defun webster-reformat (end)
  182.   "Clean up the output of the webster server, and gather words for the 
  183. completion table."
  184.   (if (not webster-reformat) nil
  185.     (goto-char end)
  186.     (let ((case-fold-search nil))
  187.       (re-search-backward "^[A-Z]+" nil t)
  188.       (if webster-fontify
  189.       (save-excursion
  190.         (previous-line 1)
  191.         (if (looking-at "^DEFINE \\([^ \n]+\\)")
  192.         (webster-fontify (match-beginning 1) (match-end 1)
  193.                  'webster-bold t))))
  194.       (cond
  195.        ((or (looking-at "^DEFINITION [0-9]")
  196.         (looking-at "^SPELLING"))
  197.     (forward-line 1)
  198.     (let ((p (point))
  199.           (indent 2))
  200.       (search-forward "\n\n" nil 0)
  201.       (narrow-to-region p (point))
  202.       (goto-char p)
  203.       (while (search-forward "\n" nil t)
  204.         (delete-char -1)
  205.         (just-one-space))
  206.       (goto-char p)
  207.       (while (not (eobp))
  208.         (if (looking-at " *\n")
  209.         (delete-region (match-beginning 0) (match-end 0)))
  210.         (cond ((looking-at "^[0-9]+ ")
  211.            (if webster-fontify
  212.                (webster-fontify (point) (match-end 0)
  213.                     'webster-bold-italic))
  214.            (goto-char (match-end 0))
  215.            (if (looking-at "[^\n0-9]+ [0-9]")
  216.                (save-excursion
  217.              (goto-char (1- (match-end 0)))
  218.              (insert "\n")))
  219.            (if (looking-at "[a-z]+\\( [a-z]+\\)*[ \n]")
  220.                (webster-intern
  221.             (buffer-substring (point) (1- (match-end 0)))))
  222.            (if webster-fontify
  223.                (webster-fontify (point) (1- (match-end 0))
  224.                     'webster-bold t))
  225.            (goto-char (1- (match-end 0)))
  226.            (if (looking-at " *\n") (forward-line 1)))
  227.           ((looking-at " *[0-9]+\\. ")
  228.            (setq indent 5)
  229.            (delete-horizontal-space)
  230.            (insert (if (= (preceding-char) ?\n) "  " "\n  "))
  231.            (skip-chars-forward "0-9. ")
  232.            (if webster-fontify
  233.                (webster-fontify
  234.             (save-excursion (beginning-of-line) (point))
  235.             (point)
  236.             'webster-bold-italic)))
  237.           ((looking-at " *\\([0-9]+\\): *")
  238.            (let ((n (buffer-substring (match-beginning 1)
  239.                           (match-end 1))))
  240.              (delete-region (match-beginning 0) (match-end 0))
  241.              (insert "\n")
  242.              (indent-to (- 6 (length n)))
  243.              (insert n " : ")
  244.              (setq indent 9)
  245.              (if webster-fontify
  246.              (webster-fontify
  247.               (save-excursion (beginning-of-line) (point))
  248.               (point)
  249.               'webster-bold-italic))))
  250.           ((looking-at " *\\([0-9]+\\)\\([a-z]+\\): *")
  251.            (let ((n (buffer-substring (match-beginning 1)
  252.                           (match-end 1)))
  253.              (m (buffer-substring (match-beginning 2)
  254.                           (match-end 2))))
  255.              (if (not (equal m "a")) (setq n " "))
  256.              (delete-region (match-beginning 0) (match-end 0))
  257.              (insert "\n")
  258.              (indent-to (- 6 (length n)))
  259.              (insert n "  ")
  260.              (insert m " : ")
  261.              (setq indent 12)
  262.              (if webster-fontify
  263.              (webster-fontify
  264.               (save-excursion (beginning-of-line) (point))
  265.               (point)
  266.               'webster-bold-italic))))
  267.           ((looking-at " *\\([0-9]+\\)\\([a-z]+\\)\\([0-9]+\\): *")
  268.            (let ((n (buffer-substring (match-beginning 1)
  269.                           (match-end 1)))
  270.              (m (buffer-substring (match-beginning 2)
  271.                           (match-end 2)))
  272.              (o (buffer-substring (match-beginning 3)
  273.                           (match-end 3))))
  274.              (if (not (equal o "1")) (setq m " "))
  275.              (if (not (equal m "a")) (setq n " "))
  276.              (delete-region (match-beginning 0) (match-end 0))
  277.              (insert "\n")
  278.              (indent-to (- 6 (length n)))
  279.              (insert n "  ")
  280.              (insert m "  ")
  281.              (insert "(" o ") : ")
  282.              (setq indent 17)
  283.              (if webster-fontify
  284.              (webster-fontify
  285.               (save-excursion (beginning-of-line) (point))
  286.               (point)
  287.               'webster-bold-italic))))
  288.           ((looking-at " *\\\\")
  289.            (setq indent 5)
  290.            (setq p (point))
  291.            (goto-char (match-end 0))
  292.            (search-forward "\\")
  293.            (if (> (current-column) fill-column)
  294.                (progn
  295.              (goto-char p)
  296.              (insert "\n")
  297.              (indent-to 18)
  298.              (search-forward "\\")))
  299.            (if webster-fontify
  300.                (webster-fontify p (point) 'webster-italic)))
  301.           ((looking-at " *\\[")
  302.            (setq indent 6)
  303.            (delete-horizontal-space)
  304.            (insert "\n")
  305.            (indent-to 5)
  306.            (forward-char 1))
  307.           ((and (= (preceding-char) ?\])
  308.             (looking-at " *:"))
  309.            (delete-horizontal-space)
  310.            (setq indent 5)
  311.            (insert "\n "))
  312.           ((looking-at " *SYN *")
  313.            (delete-region (point) (match-end 0))
  314.            (insert "\n")
  315.            (delete-horizontal-space)
  316.            (insert "  ")
  317.            (setq indent 6)
  318.            (if (looking-at "syn ")
  319.                (progn
  320.              (if webster-fontify
  321.                  (webster-fontify (point) (+ (point) 3)
  322.                           'webster-bold))
  323.              (goto-char (match-end 0))
  324.              (insert "see "))))
  325.           (t
  326.            (setq p (point))
  327.            (skip-chars-forward " ,:;-")
  328.            (if (or (looking-at
  329.               "\\([A-Z][-A-Z]+[A-Z]\\)\\( [A-Z][-A-Z]*[A-Z]\\)*")
  330.                (looking-at "[a-z][-a-z]*\\(\\.[a-z][-a-z]*\\)+"))
  331.                (let ((s (buffer-substring (point) (match-end 0))))
  332.              (if webster-fontify
  333.                  (webster-fontify (point) (match-end 0)
  334.                           'webster-bold t))
  335.              (while (string-match "\\." s)
  336.                (setq s (concat (substring s 0 (match-beginning 0))
  337.                        (substring s (match-end 0)))))
  338.              (webster-intern s)))
  339.            (skip-chars-forward "^ \\")
  340.            (if (> (current-column) fill-column)
  341.                (progn
  342.              (goto-char p)
  343.              (insert "\n")
  344.              (delete-horizontal-space)
  345.              (indent-to indent)
  346.              (skip-chars-forward " ")
  347.              (skip-chars-forward "^ \\")
  348.              )))
  349.           )))
  350.     (goto-char (point-min))
  351.     (while (looking-at "\n") (delete-char 1))
  352.     (goto-char (point-max))
  353.     (insert "\n\n")
  354.     (widen))))))
  355.  
  356. ;; " \\(\\(slang\\|cap\\|pl\\|aj\\|av\\|n\\|v\\|vt\\|vi\\)\\(,[ \n]+\\)?\\)+\n"
  357.  
  358. ;;;
  359. ;;; delete char1 and char2 if it precedes char1
  360. ;;; used to get rid of <space><return>
  361. (defun delete-char-in-region (start end char1 char2)
  362.   (goto-char start)
  363.   (setq char2 (aref char2 0))
  364.   (while (search-forward char1 end t)
  365.     (delete-char -1)
  366.     (if (= (char-after (- (point) 1)) char2)
  367.     (delete-char -1))))
  368.  
  369. ;;;###autoload
  370. (defun webster (arg)
  371. "Look up a word in the Webster's dictionary.
  372. Open a network login connection to a webster host if necessary.
  373. Communication with host is recorded in a buffer *webster*."
  374.   (interactive (list
  375.         (let ((prompt (concat "Look up word in webster ("
  376.                       (current-word) "): "))
  377.               (completion-ignore-case t))
  378.           (downcase
  379.            (if webster-reformat
  380.                (completing-read prompt webster-completion-table
  381.                     nil nil)
  382.              (read-string prompt))))))
  383.   (if (equal "" arg) (setq arg (current-word)))
  384.   (webster-send-request "DEFINE" arg))
  385.  
  386. ;;;###autoload
  387. (defun webster-endings (arg)
  388. "Look up endings for a word in the Webster's dictionary.
  389. Open a network login connection to a webster host if necessary.
  390. Communication with host is recorded in a buffer *webster*."
  391.   (interactive (list
  392.         (read-string
  393.          (concat
  394.           "Find endings for word in webster (" (current-word) "): "))))
  395.   (if (equal "" arg) (setq arg (current-word)))
  396.   (webster-send-request "ENDINGS" arg))
  397.  
  398. ;;;###autoload
  399. (defun webster-spell (arg)
  400. "Look spelling for a word in the Webster's dictionary.
  401. Open a network login connection to a webster host if necessary.
  402. Communication with host is recorded in a buffer *webster*."
  403.   (interactive (list
  404.         (read-string
  405.          (concat
  406.           "Try to spell word in webster (" (current-word) "): "))))
  407.   (if (equal "" arg) (setq arg (current-word)))
  408.   (webster-send-request "SPELL" arg))
  409.  
  410. (defun webster-send-request (kind word)
  411.   (require 'shell)
  412.   (let
  413.       ((webster-command (concat "open " webster-host " " webster-port "\n")))
  414.     
  415.     (if (or 
  416.      (not webster-buffer)
  417.      (not webster-process)
  418.      (not (eq (process-status webster-process) 'run)))
  419.     (progn
  420.       (message
  421.        (concat "Attempting to connect to server " webster-host "..."))
  422.       (setq webster-buffer
  423.         (if (not (fboundp 'make-shell)) ;emacs19
  424.             (make-comint webster-process-name "telnet")
  425.           (make-shell webster-process-name "telnet")))
  426.       (let
  427.           ((this-buffer (current-buffer)))
  428.         (set-buffer webster-buffer)
  429.         (webster-mode)
  430.         (set-buffer this-buffer))
  431.  
  432.       (setq webster-process (get-process webster-process-name))
  433.       (set-process-filter webster-process 'webster-initial-filter)
  434.       (process-send-string  webster-process webster-command)
  435.       (setq webster-running nil);
  436.       (while (not webster-running)    ; wait for feedback
  437.         (accept-process-output))))    ;
  438.     (display-buffer webster-buffer nil)
  439.     (process-send-string webster-process (concat kind " " word "\n"))))
  440.  
  441. (defun webster-quit ()
  442.    "Close connection and quit webster-mode.  Buffer is not deleted."
  443.    (interactive)
  444.    (message "Closing connection to %s..." webster-host)
  445.    (kill-process webster-process)
  446.    (message "Closing connection to %s...done" webster-host)
  447.    (bury-buffer))
  448.  
  449. (defvar webster-mode-map nil)
  450.  
  451. (defun webster-mode ()
  452.   "Major mode for interacting with on-line Webster's dictionary.
  453. \\{webster-mode-map}
  454. Use webster-mode-hook for customization."
  455.   (interactive)
  456.   (kill-all-local-variables)
  457.   (setq major-mode 'webster-mode)
  458.   (setq mode-name "Webster")
  459.   (use-local-map webster-mode-map)
  460.   (run-hooks 'webster-mode-hook))
  461.  
  462. (if webster-mode-map
  463.     nil
  464.   (setq webster-mode-map (make-sparse-keymap))
  465.   (define-key webster-mode-map "?" 'describe-mode)
  466.   (define-key webster-mode-map "d" 'webster)
  467.   (define-key webster-mode-map "e" 'webster-endings)
  468.   (define-key webster-mode-map "q" 'webster-quit)
  469.   (define-key webster-mode-map "s" 'webster-spell)
  470.   (if (string-match "XEmacs" emacs-version)
  471.       (define-key webster-mode-map 'button2 'webster-xref-word)))
  472.  
  473. ;; now in simple.el
  474. ;(defun current-word ()
  475. ;   "Word cursor is over, as a string."
  476. ;   (save-excursion
  477. ;      (let (beg end)
  478. ;     (re-search-backward "\\w" nil 2)
  479. ;     (re-search-backward "\\b" nil 2)
  480. ;     (setq beg (point))
  481. ;     (re-search-forward "\\w*\\b" nil 2)
  482. ;     (setq end (point))
  483. ;     (buffer-substring beg end))))
  484.  
  485. (defun webster-xref-word (event)
  486.   "Define the highlighted word under the mouse.
  487. Words which are known to have definitions are highlighted when the mouse
  488. moves over them.  You may define any word by selecting it with the left
  489. mouse button and then clicking middle."
  490.   (interactive "e")
  491.   (let* ((buffer (event-buffer event))
  492.      (extent (extent-at (event-point event) buffer 'highlight))
  493.      text)
  494.     (cond (extent
  495.        (setq text (save-excursion
  496.             (set-buffer buffer)
  497.             (buffer-substring
  498.              (extent-start-position extent)
  499.              (extent-end-position extent)))))
  500.       ((x-selection-owner-p) ; the selection is in this emacs process.
  501.        (setq text (x-get-selection)))
  502.       (t
  503.        (error "click on a highlighted word to define")))
  504.     (while (string-match "\\." text)
  505.       (setq text (concat (substring text 0 (match-beginning 0))
  506.              (substring text (match-end 0)))))
  507.     (message "looking up %s..." (upcase text))
  508.     (goto-char (point-max))
  509.     (webster text)))
  510.